home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / WAFPEGTP / MAKEUSE.PAS < prev    next >
Pascal/Delphi Source File  |  1994-01-16  |  13KB  |  486 lines
  1. {$A+,B-,D-,E-,F-,I+,L-,N-,O-,R+,S+,V-}
  2. {$M 16384,0,10000}
  3. program makeuse;
  4. {
  5. pull all names from bindery
  6. and write waffle user dir's
  7. rml
  8. april 1992
  9.  
  10.     Copyright (C) 1992  Dr Ross Lazarus
  11.  
  12.     This program is free software; you can redistribute it and/or modify
  13.     it under the terms of the GNU General Public License as published by
  14.     the Free Software Foundation; either version 1, or (at your option)
  15.     any later version.
  16.  
  17.     This program is distributed in the hope that it will be useful,
  18.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  19.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20.     GNU General Public License for more details.
  21.  
  22.     You should have received a copy of the GNU General Public License
  23.     along with this program; if not, write to the Free Software
  24.     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  25.  
  26.     Dr Ross Lazarus is the original copyright holder of this code.
  27.     Email: rossl@gmu.wh.su.edu.au
  28.     Mail: Department of Community Medicine,
  29.           Westmead Hospital
  30.           Westmead, NSW 2145
  31.           Australia
  32.     Fax: (+61 2) 689 1049
  33.  
  34.  
  35.  
  36. + cleaned up January 1994 for public release of code
  37.  
  38. + 2/oct 1992 fixed bug to not make a directory for the smartass blank
  39.   name that isd insists on putting into the bindery ! Ah, but it's actually
  40.   chr(255) the sneaky bastards...
  41.  
  42. }
  43.  
  44. uses dos, crt, novell;
  45.  
  46. const
  47.      wuser : string = 'f:\waffle\user';
  48.      copyright = 'Copyright (C) Dr Ross Lazarus, August 1992';
  49.      copyright2 = 'All rights reserved. Unauthorised use and distribution prohibited';
  50.      debug : boolean = false;
  51.      some : boolean = false;
  52.      prog = 'Makeuse';
  53.      ver = '0.04, 94.01.16';
  54.      waffleset = 'WAFFLE';
  55.      userdirtag = 'USER:';
  56.      hosttag = 'NODE:';
  57.      wafdir : string = '\waffle\system\static';
  58.      progname = 'Makeuse - Netware Bindery -> Waffle User converter';
  59.      version = 'Version ' + ver + ', rossl@gmu.wh.su.edu.au';
  60.  
  61. var
  62.      retcode : integer;
  63.      { scan object variables }
  64.      lastseen              : longint;
  65.      object_type           : integer;
  66.      object_name           : string;
  67.      replyid               : longint;
  68.      replytype             : integer;
  69.      replyname             : string;
  70.      replyflag             : integer;
  71.      replysecurity         : byte;
  72.      dummy,replyproperties       : integer;
  73.      home,hostname : string;
  74.      givehelp : boolean;
  75.  
  76. function mirt(trime : String) : String;
  77. { trim all blanks }
  78.  
  79. const
  80.      blank = ' ';
  81.  
  82. var
  83.    l : integer;
  84.    t : string;
  85.  
  86. begin
  87.      t := '';
  88.      for l := 1 to length(trime) do
  89.          if (trime[l] <> blank) then
  90.             t := t + trime[l];
  91.      mirt := t;
  92. end; { mirt }
  93.  
  94. Procedure explainuse;
  95. {
  96. chide
  97. and halt
  98. }
  99. begin
  100.      writeln('MAKEUSE - makes a Waffle/User subdirectory for each user in the');
  101.      writeln('Netware bindery so they can legally receive mail via Waffle.');
  102.      writeln('Waffle static file path must be available as a DOS environment');
  103.      writeln('variable called WAFFLE - waffle user: directory will be used.');
  104.      writeln('Alternatively, a path may be provided as a parameter to the directory');
  105.      writeln('below which user directories will be created - eg makeuse f:\home');
  106.      writeln('This should be run regularly so that new users created by the');
  107.      writeln('supervisor can automatically receive mail from the WafPeg Pmail UDG');
  108.      writeln('Copy and distribute without payment only !!');
  109.      writeln('Copyright (C) August 1992, Dr Ross Lazarus');
  110.      writeln('Enquiries: rossl@gmu.wh.su.edu.au');
  111.      halt(1);
  112. end;
  113.  
  114. function exists(fn : string) : boolean;
  115. {
  116. return true if fn is a file name
  117. }
  118. var
  119.    s : searchrec;
  120.  
  121. begin
  122.      {$i-}
  123.      findfirst(fn,anyfile,s);
  124.      exists := (doserror = 0) ;
  125.      {$i+}
  126. end;
  127.  
  128.  
  129. procedure listusers;
  130. {
  131. make a list of the current object type
  132. }
  133. var
  134.    newdir : string;
  135.    dummy : integer;
  136.  
  137. begin
  138.      retcode := 0;
  139.      lastseen := -1;
  140.      object_type := 1;
  141.      object_name := '*';
  142.      while (retcode = 0) do
  143.      begin
  144.           scan_object(lastseen, object_type, object_name,
  145.                  replyid, replytype, replyname, replyflag, replysecurity,
  146.                  replyproperties, retcode);
  147.           replyname := mirt(replyname);
  148.           if (retcode = 0) and (mirt(replyname) > ' ') then
  149.           begin
  150.                newdir := wuser + '\' + copy(replyname,1,8);
  151.                if not exists(newdir) then
  152.                begin
  153.                     {$i-}
  154.                     mkdir(newdir);
  155.                     dummy := ioresult;
  156.                     {$i+}
  157.                     if dummy <> 0 then
  158.                        writeln('Unable to create ',newdir)
  159.                     else
  160.                     begin
  161.                          if not some then
  162.                             some := true;
  163.                          writeln('New user added - ',newdir,' made');
  164.                     end;
  165.                end; { make new }
  166.           end; { retcode = 0 }
  167.           lastseen := replyid;
  168.      end; { scan bindery }
  169. end; { listusers }
  170.  
  171. procedure dolist;
  172. {
  173. do the work
  174. }
  175. var
  176.    thingval : byte;
  177.    status : integer;
  178.  
  179. begin
  180.      object_type := 1;
  181.      object_name := '*';
  182.      listusers;
  183.      case retcode of
  184.      $00:;
  185.      $96: writeln('Failure - retcode = server out of memory');
  186.      $ef: writeln('Failure - retcode = Invalid name');
  187.      $fe: writeln('Failure - bindery locked ');
  188.      $fe: writeln('Failure - bindery failure - try bindfix');
  189.      end;
  190. end;
  191.  
  192.  
  193. function UpcaseStr(S : String) : String;
  194. (* converts a string to upper case *)
  195.  
  196. var
  197.   P : Integer;
  198. begin
  199.   for P := 1 to Length(S) do
  200.     S[P] := Upcase(S[P]);
  201.   UpcaseStr := S;
  202. end; { Upcasestr }
  203.  
  204. function before(sep : string ; s : string) : string;
  205. {
  206. return characters up to sep in s
  207. if no sep, return whole of s
  208. }
  209. var
  210.    i : integer;
  211.  
  212. begin
  213.      i := pos(sep,s);
  214.      if (i = 0) then
  215.         before := s
  216.      else
  217.          before := copy(s,1,pred(i));
  218. end;
  219.  
  220. function after(sep :string ; var s : string) : string;
  221. {
  222. return characters after sep in s
  223. if no sep, returns null string
  224. }
  225.  
  226. var
  227.    i,j,l : integer;
  228.  
  229. begin
  230.      l := length(s);
  231.      j := length(sep);
  232.      i := pos(sep,s);
  233.      while (copy(s,i+j,j) = sep) and (i < l) do
  234.            inc(i,j);
  235.      if (i = 0) or (i >= l)  then
  236.         after := ''
  237.      else
  238.          after := copy(s,i + j,999);
  239. end; { after }
  240.  
  241. {---------------- date and time support ------------------}
  242. const
  243.      daypos = 1;
  244.      monthpos = 3;
  245.      Limit      : Array[1..13] of Integer = (31,29,31,30,31,30,31,31,30,31,30,31,31);
  246.      MthTab     : Array[1..12] of String[9] = ('Jan','Feb','Mar',
  247.                                              'Apr','May','Jun','Jul',
  248.                                              'Aug','Sep','Oct',
  249.                                              'Nov','Dec');
  250.      DayTab     : Array[0..6] of String[9] = ('Sun','Mon','Tue',
  251.                                             'Wed','Thu','Fri',
  252.                                             'Sat');
  253.  
  254. Function SysTime : String;
  255. Var
  256.   H, M, S : String[2];
  257.   hh,mm,ss,s100 : word;
  258.  
  259. Begin
  260.      gettime(hh,mm,ss,s100);
  261.      Str(hh:2, H);
  262.      Str(mm:2, M);
  263.      Str(ss:2, S);
  264.      if H[1] = ' ' then H[1] := '0';
  265.      if M[1] = ' ' then M[1] := '0';
  266.      if S[1] = ' ' then S[1] := '0';
  267.      SysTime := H + ':' + M + ':' + S
  268. End;
  269.  
  270.  
  271. Function rfc822date : String;
  272.  
  273. Var
  274.   I     : Integer;
  275.   S1,S2,today : String[30];
  276.   dd,mm,yy,d,hh,ss,s100 : word;
  277.   ds : string[2];
  278.   ys : string[4];
  279.   status,mn : integer;
  280.  
  281. Begin
  282.   getdate(yy,mm,dd,d);
  283.   str(dd,ds);
  284.   str(yy,ys);
  285.   S1 := daytab[D]+', ' + mirt(ds) + ' ' + mthtab[mm] + ' ' + ys;
  286.   rfc822Date:= s1 + ' ' + systime;
  287. End;
  288.  
  289. function findwuserdir : string;
  290. {
  291. find waffle static file from environmental variable
  292. and read to locate user dir
  293. }
  294. var
  295.    infile : text;
  296.    wuserdir,tmpstring : string;
  297.    uppers : string;
  298.    ufound,hfound : boolean;
  299.    c : char;
  300.  
  301.  
  302. function find(id,usource,source : string; var dest : string) : boolean;
  303. {
  304. seek id in the source string
  305. if found, return whatever starts with the first alphabetic character
  306. after the id label
  307. }
  308.  
  309. var
  310.    temps : string;
  311.  
  312. function alphaafter(sep,ups,s : string ) : string;
  313. {
  314. return first alpha characters after sep in s
  315. if no sep, returns null string
  316. uses uppercase version of sep and s to find substring
  317. }
  318.  
  319. const alpha : set of char = ['0'..'9','A'..'z'];
  320.  
  321. var
  322.    i,j,l : integer;
  323.    rets : string;
  324.  
  325. begin { alphaafter }
  326.      sep := upcasestr(sep);
  327.      rets := '';
  328.      l := length(s);
  329.      j := length(sep);
  330.      i := pos(sep,ups);
  331.      if (i <> 0) then
  332.      begin
  333.           i := i + j;
  334.           while not (ups[i] in alpha) and (i < l) do
  335.                 inc(i);
  336.           if (i > 0) and  (i <= l)  then
  337.              rets := copy(s,i,l);
  338.      end; { not there }
  339.      alphaafter := rets;
  340. end; { alphaafter }
  341.  
  342.  
  343. begin { find }
  344.       if (pos(id,usource) <> 0) then
  345.       begin
  346.            dest := '';
  347.            temps := alphaafter(id,usource,source);
  348.            if (temps = '') then
  349.            begin
  350.                 writeln(systime,' No ',id,' specified in ',wafdir);
  351.                 halt(1);
  352.            end
  353.            else
  354.            begin
  355.                dest := temps;
  356.                find := true;
  357.            end;
  358.       end { leave dest alone if id not found }
  359.       else
  360.           find := false;
  361. end; { find }
  362.  
  363.  
  364. begin { findwuserdir }
  365. (*
  366.  *    Waffle uses an environment variable (WAFFLE) to point at the
  367.  *    static parameters file
  368. *)
  369.      hfound := false;
  370.      ufound := false;
  371.      hostname := '?(NODE: not found in Waffle static file)';
  372.      wafdir := getenv(waffleset);
  373.      if (wafdir = '') then
  374.      begin
  375.            writeln(systime, ' ERROR: WAFFLE environment variable has not been defined');
  376.            writeln('PLEASE read the Waffle DOS documentation !!!');
  377.            writeln(systime,' halting abnormally - dos error code set to 1');
  378.            halt(1);
  379.      end;
  380.      {$i-}
  381.      assign(infile,wafdir);
  382.      reset(infile);
  383.      {$i+}
  384.      dummy := ioresult;
  385.      if (dummy <> 0) then
  386.      begin
  387.           writeln(systime ,' ERROR: Waffle static file ',wafdir,' cannot be opened');
  388.           writeln(systime, ' halting abnormally - dos error code set to 2');
  389.           halt(2);
  390.      end;
  391.      while not (hfound and ufound) and not eof(infile) do
  392.      begin
  393.            readln(infile,tmpstring);
  394.            if (tmpstring[1] <> ';') and (tmpstring[1] <> '#') and (tmpstring > '') then
  395.            begin
  396.                 tmpstring := mirt(tmpstring);
  397.                 uppers := upcasestr(tmpstring);
  398.                 if not ufound then
  399.                    ufound := find(userdirtag,uppers,tmpstring,wuserdir);
  400.                 if not hfound then
  401.                    hfound := find(hosttag,uppers,tmpstring,hostname);
  402.            end;
  403.      end; { eof }
  404.      close(infile);
  405.      if (wuserdir = '') then
  406.      begin
  407.         writeln(systime ,' ERROR: No USER directory in Waffle Static file ',wafdir);
  408.         writeln('Using \waffle\user as default');
  409.         wuserdir := '\waffle\user';
  410.      end;
  411.      findwuserdir := wuserdir;
  412. end; {findwuserdir }
  413.  
  414.  
  415.  
  416. begin { main }
  417.      getdir(0,home);
  418.      assign(input,''); { enable redirection of log output }
  419.      reset(input);
  420.      assign(output,'');
  421.      rewrite(output);
  422.      writeln('| ');
  423.      writeln(progname,' ',rfc822date);
  424.      writeln(version);
  425.      if (pos('ß',ver) <> 0) then
  426.      begin
  427.           writeln(copyright);
  428.           writeln(copyright2);
  429.           writeln('This is a BETA TEST VERSION - please do not distribute !!!');
  430.      end;
  431.      givehelp := (pos('?',paramstr(1)) <> 0);
  432.      if not givehelp and (paramcount > 0) then
  433.      begin
  434.           {$i-}
  435.           wuser := paramstr(1);
  436.           chdir(wuser);
  437.           {$i-}
  438.           dummy := ioresult;
  439.           if (dummy <> 0) then
  440.           begin
  441.                writeln('ERROR - cannot change to ',wuser);
  442.                givehelp := true;
  443.                wuser := '';
  444.           end;
  445.      end
  446.      else
  447.          wuser := findwuserdir;
  448.      if (wuser = '') or givehelp then
  449.           explainuse;
  450.      if not apiavailable then
  451.      begin
  452.           writeln(systime,' No sign of a Novell Netware network. Sorry, can''t help you');
  453.           halt(1);
  454.      end;
  455.      {$i-}
  456.      chdir(wuser);
  457.      {$i+}
  458.      dummy := ioresult;
  459.      if (dummy <> 0) then
  460.      begin
  461.           writeln(systime,' ERROR - Cannot find ',wuser);
  462.           writeln(systime,' Terminating with dos error code set to 8');
  463.           {$i-}
  464.           chdir(home);
  465.           {$i+}
  466.           dummy := ioresult;
  467.           if (dummy <> 0) then
  468.              writeln(systime,' Error - cannot return to homedir ',home);
  469.           halt(8);
  470.      end;
  471.      getserverinfo;
  472.      dolist;
  473.      {$i-}
  474.      chdir(home);
  475.      {$i+}
  476.      dummy := ioresult;
  477.      if (dummy <> 0) then
  478.         writeln(systime,' Error - cannot return to homedir ',home);
  479.      if not some then
  480.         writeln(systime,' ho hum, nothing to do. No new users found in Bindery.');
  481.      close(output);
  482. end.
  483. {
  484. makeuse.pas
  485. rml august 1992
  486. }